home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / boxwin.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  7.4 KB  |  206 lines
  1. ;;;-*-SYNTAX: ZETALISP; MODE: LISP; PACKAGE: (BOXER GLOBAL 1000); BASE: 10; FONTS: CPTFONT-*-
  2.  
  3. ;; (C) Copyright 1982-1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15.  
  16. (EVAL-WHEN (LOAD)
  17.   (TV:ADD-SYSTEM-KEY #/B 'BOXER-FRAME "Boxer" '(PROGN (MAKE-BOXER) (START-BOXER)))
  18.   (TV:ADD-TO-SYSTEM-MENU-PROGRAMS-COLUMN "Boxer"
  19.                      '(TV:SELECT-OR-CREATE-WINDOW-OF-FLAVOR 'BOXER-FRAME)
  20.                      "Boxer")
  21. ;  This is really dangerous because the Y-OR-NO-P never happens.
  22. ;  (TV:ADD-SYSTEM-KEY #/CONTROL-B 'BOXER-FRAME "Boxer"
  23. ;             '(WHEN
  24. ;            (Y-OR-N-P "Really blow away the old boxer, making a brand new one? ")
  25. ;            (MAKE-BOXER)(START-BOXER)))
  26.   )
  27.  
  28.  
  29. ;;;;**************MAIN ENTRY POINTS TO BOXER SYSTEM**************
  30.  
  31. (DEFMETHOD (BOXER-FRAME :BEFORE :INIT) (&REST IGNORE)
  32.   (SETQ TV:PANES
  33.     '((:NAME    NAME-PANE)
  34.       (:BOXER   BOXER-PANE))
  35.     TV:CONSTRAINTS
  36.     '((MAIN . ((:NAME :BOXER)
  37.           ((:NAME 1 :LINES))
  38.           ((:BOXER :EVEN)))))))
  39.  
  40. (DEFMETHOD (BOXER-FRAME :AFTER :INIT) (&REST IGNORE)
  41.   ;; Leave pointers to the various global things.
  42.   (SETQ *POINT-BLINKER* (TV:MAKE-BLINKER *BOXER-PANE* 'CURSOR-BLINKER :VISIBILITY ':BLINK)
  43.     *MOUSE-BLINKER*  (TV:MAKE-BLINKER *BOXER-PANE* 'BOXER-MOUSE-BLINKER)
  44.     *SPRITE-BLINKER* (TV:MAKE-BLINKER *BOXER-PANE* 'SPRITE-BLINKER :VISIBILITY NIL))
  45.   ;; Do various other system initializations.
  46.   (INSTANTIATE-FLAVOR 'DOIT-BOX '(#+MIT ()) ())        ;A bad but necessary hack for
  47.   (INSTANTIATE-FLAVOR 'DATA-BOX '(#+MIT ()) ())         ;flavor-hacking mixin.
  48.   (INSTANTIATE-FLAVOR 'LL-BOX '(#+MIT ()) ())
  49.   (INSTANTIATE-FLAVOR 'PORT-BOX '(#+MIT ()) ())
  50.   (INSTANTIATE-FLAVOR 'GRAPHICS-BOX '(#+MIT ()) ())
  51.   (INSTANTIATE-FLAVOR 'SPRITE-BOX '(#+MIT ()) ())
  52.   (INSTANTIATE-FLAVOR 'GRAPHICS-DATA-BOX '(#+MIT ()) ())
  53.   (INSTANTIATE-FLAVOR 'INPUT-BOX '(#+MIT ()) ())
  54.   (SETUP-REDISPLAY)
  55.   (SETUP-EDITOR T)
  56.   ;; We setup and start the boxer process from here because we
  57.   ;; need to make sure that all the initializations are complete
  58.   ;; before it gets a chance to run.
  59.   (LET ((P (TELL *BOXER-PANE* :PROCESS)))
  60.     (PROCESS-PRESET P #'BOXER-PROCESS-TOP-LEVEL-FN *BOXER-PANE*)
  61.     (PROCESS-ENABLE P)))
  62.  
  63. (DEFMETHOD (BOXER-PANE :BEFORE :INIT) (&REST IGNORE)
  64.   (SETQ TV:PROCESS (MAKE-PROCESS "Boxer"
  65.                  ':REGULAR-PDL-SIZE 9000
  66.                  ':SPECIAL-PDL-SIZE 6000)))
  67.  
  68. (DEFMETHOD (BOXER-FRAME :NAME-FOR-SELECTION) ()
  69.   "Boxer")
  70.  
  71. (DEFMETHOD (BOXER-PANE :SCREEN-ARRAY) ()
  72.   TV:SCREEN-ARRAY)
  73.  
  74.  
  75. ;;;; Interface Between the way the lispm deals with the mouse, and the
  76. ;;;; way Boxer wants to be able to deal with the mouse.
  77.  
  78. (DEFVAR MOUSE-ENTERS-WINDOW-HANDLER 'FANCY-MOUSE-ENTERS-WINDOW-HANDLER)
  79. (DEFVAR MOUSE-CLICK-HANDLER 'DEFAULT-MOUSE-CLICK-HANDLER)
  80. (DEFVAR MOUSE-MOVES-HANDLER 'FANCY-MOUSE-MOVES-HANDLER)
  81. (DEFVAR MOUSE-BUTTONS-HANDLER 'FANCY-MOUSE-BUTTONS-HANDLER)
  82. (DEFVAR WHO-LINE-DOCUMENTATION-STRING NIL) ;(set up near the def's of bu:mouse-middle, etc.)
  83.  
  84. (DEFUN SET-MOUSE-ENTERS-WINDOW-HANDLER (NEW-VALUE)
  85.   (WITHOUT-INTERRUPTS
  86.     (SETQ MOUSE-ENTERS-TENDOW-HANDLER NEW-VALUE)
  87.     (SETQ TV:MOUSE-RECONSIDER T)))
  88.                         
  89. (DEFUN SET-MOUSE-MOVES-HANDLER (NEW-VALUE)
  90.   (WITHOUT-INTERRUPTS
  91.     (SETQ MOUSE-MOVES-HANDLER NEW-VALUE)
  92.     (SETQ TV:MOUSE-RECONSIDER T)))
  93.  
  94. (DEFUN SET-MOUSE-CLICK-HANDLER (NEW-VALUE)
  95.   (SETQ MOUSE-CLICK-HANDLER NEW-VALUE))
  96.  
  97. (DEFUN SET-MOUSE-BUTTONS-HANDLER (NEW-VALUE)
  98.   (SETQ MOUSE-BUTTONS-HANDLER NEW-VALUE))
  99.  
  100. (DEFMETHOD (BOXER-PANE :HANDLE-MOUSE) ()
  101.   (FUNCALL MOUSE-ENTERS-WINDOW-HANDLER SELF))
  102.  
  103. (DEFMETHOD (BOXER-PANE :MOUSE-MOVES) (X Y)
  104.   (FUNCALL MOUSE-MOVES-HANDLER SELF X Y))
  105.  
  106. (DEFMETHOD (BOXER-PANE :MOUSE-BUTTONS) (BD X Y)
  107.   (FUNCALL MOUSE-BUTTONS-HANDLER SELF BD X Y))
  108.  
  109. (DEFMETHOD (BOXER-PANE :MOUSE-CLICK) (BUTTONS X Y)
  110.   (FUNCALL MOUSE-CLICK-HANDLER SELF BUTTONS X Y)
  111.   T)
  112.  
  113. ;;;;BUG-BOXER subsystem.
  114.  
  115. ;; This doesn't belong anyplace else that I can think of either.
  116.  
  117. (DEFFLAVOR BUG-BOXER-WINDOW
  118.     ()
  119.     (TV:TEMPORARY-WINDOW-MIXIN TV:WINDOW)
  120.   (:DEFAULT-INIT-PLIST :SAVE-BITS NIL
  121.                        :FONT-MAP `(,FONTS:MEDFNT)))
  122.  
  123.  
  124. (DEFRESOURCE BUG-BOXER-WINDOW ()
  125.   :CONSTRUCTOR (TV:MAKE-WINDOW 'BUG-BOXER-WINDOW)
  126.   :MATCHER 'T
  127.   :INITIAL-COPIES 1)
  128.  
  129. (DEFMACRO WITH-BUG-BOXER-WINDOW-SELECTED (VAR &BODY BODY)
  130.   `(USING-RESOURCE (,VAR BUG-BOXER-WINDOW)
  131.      (LET ((OLD-SELECTED-WINDOW TV:SELECTED-WINDOW)
  132.        (OVER-WINDOW (BUG-BOXER-GET-BUG-BOXER-WINDOW-OVER-WINDOW)))
  133.        (UNWIND-PROTECT
  134.      (PROGN (EXPOSE-WINDOW-OVER-WINDOW ,VAR OVER-WINDOW)
  135.         (TELL ,VAR :SELECT)
  136.         . ,BODY)
  137.      (TELL ,VAR :KILL)
  138.      (TELL OLD-SELECTED-WINDOW :SELECT)))))
  139.  
  140. (DEFUN BUG-BOXER-GET-BUG-BOXER-WINDOW-OVER-WINDOW ()
  141.   ;; Oh well looks like we are going to have to cover
  142.   ;; up the boxer-pane.
  143.   *BOXER-PANE*)
  144.  
  145. (DEFUN EXPOSE-WINDOW-OVER-WINDOW (EXPOSE-WINDOW OVER-WINDOW)
  146.   (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
  147.       (TELL OVER-WINDOW :INSIDE-EDGES)
  148.     (TELL EXPOSE-WINDOW :SET-SUPERIOR OVER-WINDOW)
  149.     (TELL EXPOSE-WINDOW :SET-EDGES LEFT TOP RIGHT BOTTOM)
  150.     (TELL EXPOSE-WINDOW :EXPOSE)))
  151.  
  152. (DEFUN BUG-BOXER ()
  153.   (WITH-BUG-BOXER-WINDOW-SELECTED BUG-WINDOW
  154.     (BUG-BOXER-PRINT-INSTRUCTIONS BUG-WINDOW)
  155.     (BUG-BOXER-SEND-MESSAGE (BUG-BOXER-GET-BUG-MESSAGE BUG-WINDOW) BUG-WINDOW)))    
  156.     
  157. (DEFUN BUG-BOXER-PRINT-INSTRUCTIONS (TERMINAL-IO)
  158.   (SEND TERMINAL-IO ':CLEAR-WINDOW)
  159.   (FORMAT T
  160.       "~%Please try to explain as carefully as possible the problem which~
  161.            ~%you encountered.~
  162.            ~% When done, pressing the <END> will send your bug message~
  163.            ~% or pressing the <ABORT> key will abort sending.~
  164.            ~%~
  165.            ~% Type Ctrl-L to clear the screen.
  166.            ~%~
  167.           "))
  168.  
  169. (DEFUN BUG-BOXER-GET-BUG-MESSAGE (&OPTIONAL (TERMINAL-IO TERMINAL-IO))
  170.   ;; Try to help the poor user out by getting a fancy rubout handler.
  171.   (COND ((AND (NULL RUBOUT-HANDLER)
  172.           (SEND TERMINAL-IO ':OPERATION-HANDLED-P ':RUBOUT-HANDLER))
  173.      (SEND TERMINAL-IO ':RUBOUT-HANDLER
  174.                        '((:PASS-THROUGH #\END NIL))
  175.                #'BUG-BOXER-GET-BUG-MESSAGE
  176.                TERMINAL-IO))
  177.     (T
  178.      (DO ((MESSAGE (MAKE-ARRAY 100 ':TYPE 'ART-STRING ':LEADER-LIST '(0)))
  179.           (CHAR (SEND TERMINAL-IO ':TYI) (SEND TERMINAL-IO ':TYI)))
  180.          ((MEMQ CHAR '(#\END NIL)) MESSAGE)
  181.        (ARRAY-PUSH-EXTEND MESSAGE CHAR)))))
  182.  
  183. (DEFUN BUG-BOXER-SEND-MESSAGE (MESSAGE REPORT-STREAM)
  184.   #+SYMBOLICS
  185.   (LET ((ZWEI:*HOST-FOR-BUG-REPORTS* (si:parse-host "Dewey"))
  186.     (ZWEI:*TYPEIN-WINDOW* REPORT-STREAM))
  187.     (MULTIPLE-VALUE-BIND (DESTINATION SYSTEM-DESCRIPTION)
  188.     (ZWEI:PARSE-BUG-ARG 'BOXER)
  189.       (SEND (MAKE-INSTANCE 'ZWEI:SEND-MESSAGE-STRING-DRAFT-MSG
  190.                ':HEADERS `(:TO ,(ZWEI:PARSE-ADDRESSES DESTINATION)
  191.                        :SUBJECT "BOXER BUG")
  192.                ':TEXT (STRING-APPEND SYSTEM-DESCRIPTION MESSAGE))
  193.         ':TRANSMIT)))
  194.   #+MIT
  195.   (ZWEI:BUG "Boxer" MESSAGE)
  196.   T)
  197.  
  198.  
  199. (DEFUN MAIL-TEXT-STRING (RECIPIENT SUBJECT MESSAGE &OPTIONAL (REPORT-STREAM TERMINAL-IO))
  200.   (LET ((ZWEI:*TYPEIN-WINDOW* REPORT-STREAM))
  201.     (SEND (MAKE-INSTANCE 'ZWEI:SEND-MESSAGE-STRING-DRAFT-MSG
  202.              ':HEADERS `(:TO ,(ZWEI:PARSE-ADDRESSES RECIPIENT)
  203.                      :SUBJECT ,SUBJECT)
  204.              ':TEXT MESSAGE)
  205.       ':TRANSMIT)))
  206.